home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / defs.lisp < prev    next >
Encoding:
Text File  |  1993-01-29  |  28.7 KB  |  903 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package :pcl)
  29.  
  30. (eval-when (compile load eval)
  31.   
  32. (defvar *defclass-times*   '(load eval))    ;Probably have to change this
  33.                         ;if you use defconstructor.
  34. (defvar *defmethod-times*  '(load eval))
  35. (defvar *defgeneric-times* '(load eval))
  36.  
  37. (defvar *boot-state* ())            ;NIL
  38.                         ;EARLY
  39.                         ;BRAID
  40.                         ;COMPLETE
  41. (defvar *fegf-started-p* nil)
  42.  
  43.  
  44. )
  45.  
  46. (eval-when (load eval)
  47.   (when (eq *boot-state* 'complete)
  48.     (error "Trying to load (or compile) PCL in an environment in which it~%~
  49.             has already been loaded.  This doesn't work, you will have to~%~
  50.             get a fresh lisp (reboot) and then load PCL."))
  51.   (when *boot-state*
  52.     (cerror "Try loading (or compiling) PCL anyways."
  53.         "Trying to load (or compile) PCL in an environment in which it~%~
  54.              has already been partially loaded.  This may not work, you may~%~
  55.              need to get a fresh lisp (reboot) and then load PCL."))
  56.   )
  57.  
  58.  
  59.  
  60. ;;;
  61. ;;; This is like fdefinition on the Lispm.  If Common Lisp had something like
  62. ;;; function specs I wouldn't need this.  On the other hand, I don't like the
  63. ;;; way this really works so maybe function specs aren't really right either?
  64. ;;; 
  65. ;;; I also don't understand the real implications of a Lisp-1 on this sort of
  66. ;;; thing.  Certainly some of the lossage in all of this is because these
  67. ;;; SPECs name global definitions.
  68. ;;;
  69. ;;; Note that this implementation is set up so that an implementation which
  70. ;;; has a 'real' function spec mechanism can use that instead and in that way
  71. ;;; get rid of setf generic function names.
  72. ;;;
  73. (defmacro parse-gspec (spec
  74.                (non-setf-var . non-setf-case)
  75.                (setf-var . setf-case))
  76.   (declare (indentation 1 1))
  77.   (once-only (spec)
  78.     `(cond (#-setf (symbolp ,spec) #+setf t
  79.         (let ((,non-setf-var ,spec)) ,@non-setf-case))
  80.        #-setf
  81.        ((and (listp ,spec)
  82.          (eq (car ,spec) 'setf)
  83.          (symbolp (cadr ,spec)))
  84.         (let ((,setf-var (cadr ,spec))) ,@setf-case))
  85.        #-setf
  86.        (t
  87.         (error
  88.           "Can't understand ~S as a generic function specifier.~%~
  89.                It must be either a symbol which can name a function or~%~
  90.                a list like ~S, where the car is the symbol ~S and the cadr~%~
  91.                is a symbol which can name a generic function."
  92.           ,spec '(setf <foo>) 'setf)))))
  93.  
  94. ;;;
  95. ;;; If symbol names a function which is traced or advised, return the
  96. ;;; unadvised, traced etc. definition.  This lets me get at the generic
  97. ;;; function object even when it is traced.
  98. ;;;
  99. (defun unencapsulated-fdefinition (symbol)
  100.   #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))
  101.   #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))
  102.   #+excl  (or (excl::encapsulated-basic-definition symbol)
  103.           (symbol-function symbol))
  104.   #+xerox (il:virginfn symbol)
  105.   #+setf (fdefinition symbol)
  106.   #+kcl (symbol-function
  107.       (let ((sym (get symbol 'si::traced)) first-form)
  108.         (if (and sym
  109.              (consp (symbol-function symbol))
  110.              (consp (setq first-form (nth 3 (symbol-function symbol))))
  111.              (eq (car first-form) 'si::trace-call))
  112.         sym
  113.         symbol)))
  114.   #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol))
  115.  
  116. ;;;
  117. ;;; If symbol names a function which is traced or advised, redefine
  118. ;;; the `real' definition without affecting the advise.
  119. ;;;
  120. (defun fdefine-carefully (name new-definition)
  121.   #+Lispm (si:fdefine name new-definition t t)
  122.   #+Lucid (let ((lucid::*redefinition-action* nil))
  123.         (setf (symbol-function name) new-definition))
  124.   #+excl  (setf (symbol-function name) new-definition)
  125.   #+xerox (let ((advisedp (member name il:advisedfns :test #'eq))
  126.                 (brokenp (member name il:brokenfns :test #'eq)))
  127.         ;; In XeroxLisp (late of envos) tracing is implemented
  128.         ;; as a special case of "breaking".  Advising, however,
  129.         ;; is treated specially.
  130.             (xcl:unadvise-function name :no-error t)
  131.             (xcl:unbreak-function name :no-error t)
  132.             (setf (symbol-function name) new-definition)
  133.             (when brokenp (xcl:rebreak-function name))
  134.             (when advisedp (xcl:readvise-function name)))
  135.   #+(and setf (not cmu)) (setf (fdefinition name) new-definition)
  136.   #+kcl (setf (symbol-function 
  137.            (let ((sym (get name 'si::traced)) first-form)
  138.          (if (and sym
  139.               (consp (symbol-function name))
  140.               (consp (setq first-form
  141.                        (nth 3 (symbol-function name))))
  142.               (eq (car first-form) 'si::trace-call))
  143.              sym
  144.              name)))
  145.           new-definition)
  146.   #+cmu (progn
  147.       (c::%%defun name new-definition nil)
  148.       (c::note-name-defined name :function)
  149.       new-definition)
  150.   #-(or Lispm Lucid excl Xerox setf kcl cmu)
  151.   (setf (symbol-function name) new-definition))
  152.  
  153. (defun gboundp (spec)
  154.   (parse-gspec spec
  155.     (name (fboundp name))
  156.     (name (fboundp (get-setf-function-name name)))))
  157.  
  158. (defun gmakunbound (spec)
  159.   (parse-gspec spec
  160.     (name (fmakunbound name))
  161.     (name (fmakunbound (get-setf-function-name name)))))
  162.  
  163. (defun gdefinition (spec)
  164.   (parse-gspec spec
  165.     (name (or #-setf (macro-function name)        ;??
  166.           (unencapsulated-fdefinition name)))
  167.     (name (unencapsulated-fdefinition (get-setf-function-name name)))))
  168.  
  169. (defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec)
  170.   (parse-gspec spec
  171.     (name (fdefine-carefully name new-value))
  172.     (name (fdefine-carefully (get-setf-function-name name) new-value))))
  173.  
  174.  
  175. (proclaim '(special *the-class-t* 
  176.                 *the-class-vector* *the-class-symbol*
  177.                     *the-class-string* *the-class-sequence*
  178.                     *the-class-rational* *the-class-ratio*
  179.                     *the-class-number* *the-class-null* *the-class-list*
  180.                     *the-class-integer* *the-class-float* *the-class-cons*
  181.                     *the-class-complex* *the-class-character*
  182.                     *the-class-bit-vector* *the-class-array*
  183.  
  184.                     *the-class-slot-object*
  185.                     *the-class-standard-object*
  186.                     *the-class-structure-object*
  187.                     *the-class-class*
  188.                     *the-class-generic-function*
  189.                     *the-class-built-in-class*
  190.                     *the-class-slot-class*
  191.                     *the-class-structure-class*
  192.                     *the-class-standard-class*
  193.                     *the-class-funcallable-standard-class*
  194.                     *the-class-method*
  195.                     *the-class-standard-method*
  196.                 *the-class-standard-reader-method*
  197.                 *the-class-standard-writer-method*
  198.                 *the-class-standard-boundp-method*
  199.                     *the-class-standard-generic-function*
  200.                     *the-class-standard-effective-slot-definition*
  201.  
  202.                     *the-eslotd-standard-class-slots*
  203.                     *the-eslotd-funcallable-standard-class-slots*))
  204.  
  205. (proclaim '(special *the-wrapper-of-t*
  206.                     *the-wrapper-of-vector* *the-wrapper-of-symbol*
  207.                     *the-wrapper-of-string* *the-wrapper-of-sequence*
  208.                     *the-wrapper-of-rational* *the-wrapper-of-ratio*
  209.                     *the-wrapper-of-number* *the-wrapper-of-null*
  210.                     *the-wrapper-of-list* *the-wrapper-of-integer*
  211.                     *the-wrapper-of-float* *the-wrapper-of-cons*
  212.                     *the-wrapper-of-complex* *the-wrapper-of-character*
  213.                     *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
  214.  
  215. (defun coerce-to-class (class &optional make-forward-referenced-class-p)
  216.   (if (symbolp class)
  217.       (or (find-class class (not make-forward-referenced-class-p))
  218.       (ensure-class class))
  219.       class))
  220.  
  221. (defun specializer-from-type (type &aux args)
  222.   (when (consp type)
  223.     (setq args (cdr type) type (car type)))
  224.   (cond ((symbolp type)
  225.      (or (and (null args) (find-class type))
  226.          (ecase type
  227.            (class    (coerce-to-class (car args)))
  228.            (prototype (make-instance 'class-prototype-specializer
  229.                      :object (coerce-to-class (car args))))
  230.            (class-eq (class-eq-specializer (coerce-to-class (car args))))
  231.            (eql      (intern-eql-specializer (car args))))))
  232.     ((specializerp type) type)))
  233.  
  234. (defun type-from-specializer (specl)
  235.   (cond ((eq specl 't)
  236.      't)
  237.     ((consp specl)
  238.          (unless (member (car specl) '(class prototype class-eq eql))
  239.            (error "~S is not a legal specializer type" specl))
  240.          specl)
  241.         ((progn
  242.        (when (symbolp specl)
  243.          ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
  244.          (setq specl (find-class specl)))
  245.        (or (not (eq *boot-state* 'complete))
  246.            (specializerp specl)))
  247.      (specializer-type specl))
  248.         (t
  249.          (error "~s is neither a type nor a specializer" specl))))
  250.  
  251. (defun type-class (type)
  252.   (declare (special *the-class-t*))
  253.   (setq type (type-from-specializer type))
  254.   (if (atom type)
  255.       (if (eq type 't)
  256.       *the-class-t*
  257.       (error "bad argument to type-class"))
  258.       (case (car type)
  259.         (eql (class-of (cadr type)))
  260.     (prototype (class-of (cadr type))) ;?
  261.         (class-eq (cadr type))
  262.         (class (cadr type)))))
  263.  
  264. (defun class-eq-type (class)
  265.   (specializer-type (class-eq-specializer class)))
  266.  
  267. (defun inform-type-system-about-std-class (name)
  268.   (let ((predicate-name (make-type-predicate-name name)))
  269.     (setf (gdefinition predicate-name) (make-type-predicate name))
  270.     (do-satisfies-deftype name predicate-name)))
  271.  
  272. (defun make-type-predicate (name)
  273.   (let ((cell (find-class-cell name)))
  274.     #'(lambda (x)
  275.     (funcall (the function (find-class-cell-predicate cell)) x))))
  276.  
  277.  
  278. ;This stuff isn't right.  Good thing it isn't used.
  279. ;The satisfies predicate has to be a symbol.  There is no way to
  280. ;construct such a symbol from a class object if class names change.
  281. (defun class-predicate (class)
  282.   (when (symbolp class) (setq class (find-class class)))
  283.   #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
  284.  
  285. (defun make-class-eq-predicate (class)
  286.   (when (symbolp class) (setq class (find-class class)))
  287.   #'(lambda (object) (eq class (class-of object))))
  288.  
  289. (defun make-eql-predicate (eql-object)
  290.   #'(lambda (object) (eql eql-object object)))
  291.  
  292. #|| ; The argument to satisfies must be a symbol.  
  293. (deftype class (&optional class)
  294.   (if class
  295.       `(satisfies ,(class-predicate class))
  296.       `(satisfies ,(class-predicate 'class))))
  297.  
  298. (deftype class-eq (class)
  299.   `(satisfies ,(make-class-eq-predicate class)))
  300. ||#
  301.  
  302. #-excl
  303. (deftype eql (type-object)
  304.   `(member ,type-object))
  305.  
  306.  
  307.  
  308. ;;;
  309. ;;; These functions are a pale imitiation of their namesake.  They accept
  310. ;;; class objects or types where they should.
  311. ;;; 
  312. (defun *normalize-type (type)
  313.   (cond ((consp type)
  314.          (if (member (car type) '(not and or))
  315.              `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
  316.              (if (null (cdr type))
  317.                  (*normalize-type (car type))
  318.                  type)))
  319.         ((symbolp type)
  320.          (let ((class (find-class type nil)))
  321.            (if class
  322.                (let ((type (specializer-type class)))
  323.          (if (listp type) type `(,type)))
  324.                `(,type))))
  325.         ((or (not (eq *boot-state* 'complete))
  326.          (specializerp type))
  327.      (specializer-type type))
  328.         (t
  329.          (error "~s is not a type" type))))
  330.  
  331. (defun unparse-type-list (tlist)
  332.   (mapcar #'unparse-type tlist))
  333.  
  334. (defun unparse-type (type)
  335.   (if (atom type)
  336.       (if (specializerp type)
  337.           (unparse-type (specializer-type type))
  338.           type)
  339.       (case (car type)
  340.         (eql type)
  341.         (class-eq `(class-eq ,(class-name (cadr type))))
  342.         (class (class-name (cadr type)))
  343.         (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
  344.  
  345. (defun convert-to-system-type (type)
  346.   (case (car type)
  347.     ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type))))
  348.     (class (class-name (cadr type))) ; it had better be a named class
  349.     (class-eq (class-name (cadr type))) ; this one is impossible to do right
  350.     (eql type)
  351.     (t (if (null (cdr type))
  352.        (car type)
  353.        type))))
  354.  
  355. (defun *typep (object type)
  356.   (setq type (*normalize-type type))
  357.   (cond ((member (car type) '(eql wrapper-eq class-eq class))
  358.          (specializer-applicable-using-type-p type `(eql ,object)))
  359.         ((eq (car type) 'not)
  360.          (not (*typep object (cadr type))))
  361.         (t
  362.          (typep object (convert-to-system-type type)))))
  363.  
  364. ;Writing the missing NOT and AND clauses will improve
  365. ;the quality of code generated by generate-discrimination-net, but
  366. ;calling subtypep in place of just returning (values nil nil) can be
  367. ;very slow.  *subtypep is used by PCL itself, and must be fast.
  368. (defun *subtypep (type1 type2)
  369.   (if (equal type1 type2)
  370.       (values t t)
  371.       (if (eq *boot-state* 'early)
  372.       (values (eq type1 type2) t)
  373.       (let ((*in-precompute-effective-methods-p* t)) 
  374.         (declare (special *in-precompute-effective-methods-p*))
  375.             ;; *in-precompute-effective-methods-p* is not a good name.
  376.         ;; It changes the way class-applicable-using-class-p works.
  377.         (setq type1 (*normalize-type type1))
  378.         (setq type2 (*normalize-type type2))
  379.         (case (car type2)
  380.           (not
  381.            (values nil (not (equal (cadr type2) type1))))
  382.           (and
  383.            (values nil nil)) ; Should improve this.
  384.           ((eql wrapper-eq class-eq class)
  385.            (multiple-value-bind (app-p maybe-app-p)
  386.            (specializer-applicable-using-type-p type2 type1)
  387.          (values app-p (or app-p (not maybe-app-p)))))
  388.           (t
  389.            (subtypep (convert-to-system-type type1)
  390.              (convert-to-system-type type2))))))))
  391.  
  392. (defun do-satisfies-deftype (name predicate)
  393.   #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
  394.   (let* ((specifier `(satisfies ,predicate))
  395.      (expand-fn #'(lambda (&rest ignore)
  396.             (declare (ignore ignore))
  397.             specifier)))
  398.     ;; Specific ports can insert their own way of doing this.  Many
  399.     ;; ports may find the expand-fn defined above useful.
  400.     ;;
  401.     (or #+:Genera
  402.     (setf (get name 'deftype) expand-fn)
  403.     #+(and :Lucid (not :Prime))
  404.     (system::define-macro `(deftype ,name) expand-fn nil)
  405.     #+ExCL
  406.     (setf (get name 'excl::deftype-expander) expand-fn)
  407.     #+:coral
  408.     (setf (get name 'ccl::deftype-expander) expand-fn)))
  409.   #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
  410.   ;; This is the default for ports for which we don't know any
  411.   ;; better.  Note that for most ports, providing this definition
  412.   ;; should just speed up class definition.  It shouldn't have an
  413.   ;; effect on performance of most user code.
  414.   (eval `(deftype ,name () '(satisfies ,predicate))))
  415.  
  416. (defun make-type-predicate-name (name &optional kind)
  417.   (if (symbol-package name)
  418.       (intern (format nil
  419.               "~@[~A ~]TYPE-PREDICATE ~A ~A"
  420.               kind
  421.               (package-name (symbol-package name))
  422.               (symbol-name name))
  423.           *the-pcl-package*)
  424.       (make-symbol (format nil
  425.                "~@[~A ~]TYPE-PREDICATE ~A"
  426.                kind
  427.                (symbol-name name)))))
  428.  
  429.  
  430.  
  431. (defvar *built-in-class-symbols* ())
  432. (defvar *built-in-wrapper-symbols* ())
  433.  
  434. (defun get-built-in-class-symbol (class-name)
  435.   (or (cadr (assq class-name *built-in-class-symbols*))
  436.       (let ((symbol (intern (format nil
  437.                     "*THE-CLASS-~A*"
  438.                     (symbol-name class-name))
  439.                 *the-pcl-package*)))
  440.     (push (list class-name symbol) *built-in-class-symbols*)
  441.     symbol)))
  442.  
  443. (defun get-built-in-wrapper-symbol (class-name)
  444.   (or (cadr (assq class-name *built-in-wrapper-symbols*))
  445.       (let ((symbol (intern (format nil
  446.                     "*THE-WRAPPER-OF-~A*"
  447.                     (symbol-name class-name))
  448.                 *the-pcl-package*)))
  449.     (push (list class-name symbol) *built-in-wrapper-symbols*)
  450.     symbol)))
  451.  
  452.  
  453.  
  454.  
  455. (pushnew 'class *variable-declarations*)
  456. (pushnew 'variable-rebinding *variable-declarations*)
  457.  
  458. (defun variable-class (var env)
  459.   (caddr (variable-declaration 'class var env)))
  460.  
  461. (defvar *name->class->slotd-table* (make-hash-table))
  462.  
  463.  
  464. ;;;
  465. ;;; This is used by combined methods to communicate the next methods to
  466. ;;; the methods they call.  This variable is captured by a lexical variable
  467. ;;; of the methods to give it the proper lexical scope.
  468. ;;; 
  469. (defvar *next-methods* nil)
  470.  
  471. (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
  472.  
  473. (defvar *umi-gfs*)
  474. (defvar *umi-complete-classes*)
  475. (defvar *umi-reorder*)
  476.  
  477. (defvar *invalidate-discriminating-function-force-p* ())
  478. (defvar *invalid-dfuns-on-stack* ())
  479.  
  480.  
  481. (defvar *standard-method-combination*)
  482.  
  483. (defvar *slotd-unsupplied* (list '*slotd-unsupplied*))    ;***
  484.  
  485.  
  486. (defmacro define-gf-predicate (predicate-name &rest classes)
  487.   `(progn 
  488.      (defmethod ,predicate-name ((x t)) nil)
  489.      ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
  490.            classes)))
  491.  
  492. (defun make-class-predicate-name (name)
  493.   (intern (format nil "~A::~A class predicate"
  494.           (package-name (symbol-package name))
  495.           name)
  496.       *the-pcl-package*))
  497.  
  498. (defun plist-value (object name)
  499.   (getf (object-plist object) name))
  500.  
  501. (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)
  502.   (if new-value
  503.       (setf (getf (object-plist object) name) new-value)
  504.       (progn
  505.         (remf (object-plist object) name)
  506.         nil)))
  507.  
  508.  
  509.  
  510. (defvar *built-in-classes*
  511.   ;;
  512.   ;; name       supers     subs                     cdr of cpl
  513.   ;; prototype
  514.   '(;(t         ()         (number sequence array character symbol) ())
  515.     (number     (t)        (complex float rational) (t))
  516.     (complex    (number)   ()                       (number t)
  517.      #c(1 1))
  518.     (float      (number)   ()                       (number t)
  519.      1.0)
  520.     (rational   (number)   (integer ratio)          (number t))
  521.     (integer    (rational) ()                       (rational number t)
  522.      1)
  523.     (ratio      (rational) ()                       (rational number t)
  524.      1/2)
  525.  
  526.     (sequence   (t)        (list vector)            (t))
  527.     (list       (sequence) (cons null)              (sequence t))
  528.     (cons       (list)     ()                       (list sequence t)
  529.      (nil))
  530.     
  531.  
  532.     (array      (t)        (vector)                 (t)
  533.      #2A((NIL)))
  534.     (vector     (array
  535.          sequence) (string bit-vector)      (array sequence t)
  536.      #())
  537.     (string     (vector)   ()                       (vector array sequence t)
  538.      "")
  539.     (bit-vector (vector)   ()                       (vector array sequence t)
  540.      #*1)
  541.     (character  (t)        ()                       (t)
  542.      #\c)
  543.    
  544.     (symbol     (t)        (null)                   (t)
  545.      symbol)
  546.     (null       (symbol 
  547.          list)     ()                       (symbol list sequence t)
  548.      nil)))
  549.  
  550.  
  551. ;;;
  552. ;;; The classes that define the kernel of the metabraid.
  553. ;;;
  554. (defclass t () ()
  555.   (:metaclass built-in-class))
  556.  
  557. (defclass slot-object (t) ()
  558.   (:metaclass slot-class))
  559.  
  560. (defclass structure-object (slot-object) ()
  561.   (:metaclass structure-class))
  562.  
  563. (defstruct (structure-object
  564.          (:constructor |STRUCTURE-OBJECT class constructor|)))
  565.  
  566. (defclass standard-object (slot-object) ())
  567.  
  568. (defclass metaobject (standard-object) ())
  569.  
  570. (defclass specializer (metaobject) 
  571.      ((type
  572.         :initform nil
  573.         :reader specializer-type)))
  574.  
  575. (defclass definition-source-mixin (standard-object)
  576.      ((source
  577.     :initform (load-truename)
  578.     :reader definition-source
  579.     :initarg :definition-source)))
  580.  
  581. (defclass plist-mixin (standard-object)
  582.      ((plist
  583.     :initform ()
  584.     :accessor object-plist)))
  585.  
  586. (defclass documentation-mixin (plist-mixin)
  587.      ())
  588.  
  589. (defclass dependent-update-mixin (plist-mixin)
  590.     ())
  591.  
  592. ;;;
  593. ;;; The class CLASS is a specified basic class.  It is the common superclass
  594. ;;; of any kind of class.  That is any class that can be a metaclass must
  595. ;;; have the class CLASS in its class precedence list.
  596. ;;; 
  597. (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
  598.          specializer)
  599.      ((name
  600.     :initform nil
  601.     :initarg  :name
  602.     :accessor class-name)
  603.       (class-eq-specializer
  604.         :initform nil
  605.         :reader class-eq-specializer)
  606.       (direct-superclasses
  607.     :initform ()
  608.     :reader class-direct-superclasses)
  609.       (direct-subclasses
  610.     :initform ()
  611.     :reader class-direct-subclasses)
  612.       (direct-methods
  613.     :initform (cons nil nil))
  614.       (predicate-name
  615.         :initform nil
  616.     :reader class-predicate-name)))
  617.  
  618. ;;;
  619. ;;; The class PCL-CLASS is an implementation-specific common superclass of
  620. ;;; all specified subclasses of the class CLASS.
  621. ;;; 
  622. (defclass pcl-class (class)
  623.      ((class-precedence-list
  624.     :reader class-precedence-list)
  625.       (can-precede-list
  626.         :initform ()
  627.     :reader class-can-precede-list)
  628.       (incompatible-superclass-list
  629.         :initform ()
  630.     :accessor class-incompatible-superclass-list)
  631.       (wrapper
  632.     :initform nil
  633.     :reader class-wrapper)
  634.       (prototype
  635.     :initform nil
  636.     :reader class-prototype)))
  637.  
  638. (defclass slot-class (pcl-class)
  639.      ((direct-slots
  640.     :initform ()
  641.     :accessor class-direct-slots)
  642.       (slots
  643.         :initform ()
  644.     :accessor class-slots)
  645.       (initialize-info
  646.         :initform nil
  647.     :accessor class-initialize-info)))
  648.  
  649. ;;;
  650. ;;; The class STD-CLASS is an implementation-specific common superclass of
  651. ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
  652. ;;; 
  653. (defclass std-class (slot-class)
  654.      ())
  655.  
  656. (defclass standard-class (std-class)
  657.      ())
  658.  
  659. (defclass funcallable-standard-class (std-class)
  660.      ())
  661.     
  662. (defclass forward-referenced-class (pcl-class) ())
  663.  
  664. (defclass built-in-class (pcl-class) ())
  665.  
  666. (defclass structure-class (slot-class)
  667.      ((defstruct-form
  668.         :initform ()
  669.     :accessor class-defstruct-form)
  670.       (defstruct-constructor
  671.         :initform nil
  672.     :accessor class-defstruct-constructor)
  673.       (from-defclass-p
  674.         :initform nil
  675.     :initarg :from-defclass-p)))
  676.      
  677.  
  678. (defclass specializer-with-object (specializer) ())
  679.  
  680. (defclass exact-class-specializer (specializer) ())
  681.  
  682. (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
  683.   ((object :initarg :class :reader specializer-class :reader specializer-object)))
  684.  
  685. (defclass class-prototype-specializer (specializer-with-object)
  686.   ((object :initarg :class :reader specializer-class :reader specializer-object)))
  687.  
  688. (defclass eql-specializer (exact-class-specializer specializer-with-object)
  689.   ((object :initarg :object :reader specializer-object 
  690.        :reader eql-specializer-object)))
  691.  
  692. (defvar *eql-specializer-table* (make-hash-table :test 'eql))
  693.  
  694. (defun intern-eql-specializer (object)
  695.   (or (gethash object *eql-specializer-table*)
  696.       (setf (gethash object *eql-specializer-table*)
  697.         (make-instance 'eql-specializer :object object))))
  698.  
  699.  
  700. ;;;
  701. ;;; Slot definitions.
  702. ;;;
  703. (defclass slot-definition (metaobject) 
  704.      ((name
  705.     :initform nil
  706.     :initarg :name
  707.         :accessor slot-definition-name)
  708.       (initform
  709.     :initform nil
  710.     :initarg :initform
  711.     :accessor slot-definition-initform)
  712.       (initfunction
  713.     :initform nil
  714.     :initarg :initfunction
  715.     :accessor slot-definition-initfunction)
  716.       (readers
  717.     :initform nil
  718.     :initarg :readers
  719.     :accessor slot-definition-readers)
  720.       (writers
  721.     :initform nil
  722.     :initarg :writers
  723.     :accessor slot-definition-writers)
  724.       (initargs
  725.     :initform nil
  726.     :initarg :initargs
  727.     :accessor slot-definition-initargs)
  728.       (type
  729.     :initform t
  730.     :initarg :type
  731.     :accessor slot-definition-type)
  732.       (documentation
  733.     :initform ""
  734.     :initarg :documentation)
  735.       (class
  736.         :initform nil
  737.     :initarg :class
  738.     :accessor slot-definition-class)))
  739.  
  740. (defclass standard-slot-definition (slot-definition)
  741.   ((allocation
  742.     :initform :instance
  743.     :initarg :allocation
  744.     :accessor slot-definition-allocation)))
  745.  
  746. (defclass structure-slot-definition (slot-definition)
  747.   ((defstruct-accessor-symbol 
  748.      :initform nil
  749.      :initarg :defstruct-accessor-symbol
  750.      :accessor slot-definition-defstruct-accessor-symbol)
  751.    (internal-reader-function 
  752.      :initform nil
  753.      :initarg :internal-reader-function
  754.      :accessor slot-definition-internal-reader-function)
  755.    (internal-writer-function 
  756.      :initform nil
  757.      :initarg :internal-writer-function
  758.      :accessor slot-definition-internal-writer-function)))
  759.  
  760. (defclass direct-slot-definition (slot-definition)
  761.   ())
  762.  
  763. (defclass effective-slot-definition (slot-definition)
  764.   ((reader-function ; #'(lambda (object) ...)
  765.     :accessor slot-definition-reader-function)
  766.    (writer-function ; #'(lambda (new-value object) ...)
  767.     :accessor slot-definition-writer-function)
  768.    (boundp-function ; #'(lambda (object) ...)
  769.     :accessor slot-definition-boundp-function)
  770.    (accessor-flags
  771.     :initform 0)))
  772.  
  773. (defclass standard-direct-slot-definition (standard-slot-definition
  774.                        direct-slot-definition)
  775.   ())
  776.  
  777. (defclass standard-effective-slot-definition (standard-slot-definition
  778.                           effective-slot-definition)
  779.   ((location ; nil, a fixnum, a cons: (slot-name . value)
  780.     :initform nil
  781.     :accessor slot-definition-location)))
  782.  
  783. (defclass structure-direct-slot-definition (structure-slot-definition
  784.                         direct-slot-definition)
  785.   ())
  786.  
  787. (defclass structure-effective-slot-definition (structure-slot-definition
  788.                            effective-slot-definition)
  789.   ())
  790.  
  791. (defclass method (metaobject) ())
  792.  
  793. (defclass standard-method (definition-source-mixin plist-mixin method)
  794.      ((generic-function
  795.     :initform nil    
  796.     :accessor method-generic-function)
  797. ;     (qualifiers
  798. ;    :initform ()
  799. ;    :initarg  :qualifiers
  800. ;    :reader method-qualifiers)
  801.       (specializers
  802.     :initform ()
  803.     :initarg  :specializers
  804.     :reader method-specializers)
  805.       (lambda-list
  806.     :initform ()
  807.     :initarg  :lambda-list
  808.     :reader method-lambda-list)
  809.       (function
  810.     :initform nil
  811.     :initarg :function)        ;no writer
  812.       (fast-function
  813.     :initform nil
  814.     :initarg :fast-function        ;no writer
  815.     :reader method-fast-function)
  816. ;     (documentation
  817. ;    :initform nil
  818. ;    :initarg  :documentation
  819. ;    :reader method-documentation)
  820.       ))
  821.  
  822. (defclass standard-accessor-method (standard-method)
  823.      ((slot-name :initform nil
  824.          :initarg :slot-name
  825.          :reader accessor-method-slot-name)
  826.       (slot-definition :initform nil
  827.                :initarg :slot-definition
  828.                :reader accessor-method-slot-definition)))
  829.  
  830. (defclass standard-reader-method (standard-accessor-method) ())
  831.  
  832. (defclass standard-writer-method (standard-accessor-method) ())
  833.  
  834. (defclass standard-boundp-method (standard-accessor-method) ())
  835.  
  836. (defclass generic-function (dependent-update-mixin
  837.                 definition-source-mixin
  838.                 documentation-mixin
  839.                 metaobject)
  840.      ()
  841.   (:metaclass funcallable-standard-class))
  842.     
  843. (defclass standard-generic-function (generic-function)
  844.      ((name
  845.     :initform nil
  846.     :initarg :name
  847.     :accessor generic-function-name)
  848.       (methods
  849.     :initform ()
  850.     :accessor generic-function-methods)
  851.       (method-class
  852.     :initarg :method-class
  853.     :accessor generic-function-method-class)
  854.       (method-combination
  855.     :initarg :method-combination
  856.     :accessor generic-function-method-combination)
  857.       (arg-info
  858.         :initform (make-arg-info)
  859.     :reader gf-arg-info)
  860.       (dfun-state
  861.     :initform ()
  862.     :accessor gf-dfun-state)
  863.       (pretty-arglist
  864.     :initform ()
  865.     :accessor gf-pretty-arglist)
  866.       )
  867.   (:metaclass funcallable-standard-class)
  868.   (:default-initargs :method-class *the-class-standard-method*
  869.              :method-combination *standard-method-combination*))
  870.  
  871. (defclass method-combination (metaobject) ())
  872.  
  873. (defclass standard-method-combination
  874.       (definition-source-mixin method-combination)
  875.      ((type          :reader method-combination-type
  876.                  :initarg :type)
  877.       (documentation :reader method-combination-documentation
  878.              :initarg :documentation)
  879.       (options       :reader method-combination-options
  880.                  :initarg :options)))
  881.  
  882. (defparameter *early-class-predicates*
  883.   '((specializer specializerp)
  884.     (exact-class-specializer exact-class-specializer-p)
  885.     (class-eq-specializer class-eq-specializer-p)
  886.     (eql-specializer eql-specializer-p)
  887.     (class classp)
  888.     (slot-class slot-class-p)
  889.     (standard-class standard-class-p)
  890.     (funcallable-standard-class funcallable-standard-class-p)
  891.     (structure-class structure-class-p)
  892.     (forward-referenced-class forward-referenced-class-p)
  893.     (method method-p)
  894.     (standard-method standard-method-p)
  895.     (standard-accessor-method standard-accessor-method-p)
  896.     (standard-reader-method standard-reader-method-p)
  897.     (standard-writer-method standard-writer-method-p)
  898.     (standard-boundp-method standard-boundp-method-p)
  899.     (generic-function generic-function-p)
  900.     (standard-generic-function standard-generic-function-p)
  901.     (method-combination method-combination-p)))
  902.  
  903.